home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / wantan1a / modmac~1.bas < prev    next >
Encoding:
BASIC Source File  |  1999-09-04  |  8.6 KB  |  203 lines
  1. Attribute VB_Name = "modMacroFont"
  2. Option Explicit
  3.  
  4. Public Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
  5. Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
  6.  
  7. Public Sub TextToPictureBox(txtSource As textbox, picDestination As PictureBox)
  8.     'this sub will take the text in our textbox and draw it to our
  9.     'picturebox. first you will see that i reset the backcolor of
  10.     'the picturebox. i do this so that our picturebox is "erased"
  11.     'before we draw to it instead of drawing on top of our old text.
  12.     'after using the textout api, notice that i will refresh the
  13.     'picturebox. this is necessary since i have the picturebox's
  14.     'autoredraw property set to true.
  15.     picDestination.BackColor = vbWhite
  16.     If txtSource.Text = " " Then
  17.         picDestination.Refresh
  18.     Else
  19.         Call TextOut(picDestination.hDC, 0&, 0&, txtSource.Text, Len(txtSource.Text))
  20.         picDestination.Refresh
  21.     End If
  22. End Sub
  23.  
  24. Public Function Convert(picSource As PictureBox) As String
  25.     'this is the function which makes this all work. because this
  26.     'function is more complicated than the rest, i will step through
  27.     'it instead of explaining it all hear.
  28.     Dim lngDoWidth As Long, lngDoHeight As Long
  29.     Dim lngTop As Long, lngBottom As Long
  30.     Dim strChar As String, strLine As String
  31.     Dim strMacro As String, lngFix As Long, blnFix As Boolean
  32.     Dim strFinal As String, strTmp As String
  33.     
  34.     For lngDoHeight& = 1 To picSource.ScaleHeight Step 2
  35.     'we are starting our first for/next loop here. notice that this
  36.     'loop is according to the height of the picturebox in pixels. we
  37.     'are stepping through every other line here (hence the step 2).
  38.     'we do this since when converting to our ascii art we must consider
  39.     'two lines at a time as we will see later.
  40.         strLine$ = " "
  41.         For lngDoWidth& = 1 To picSource.ScaleWidth Step 1
  42.         'here we are starting our loop which is according to the
  43.         'picturebox's width. this loop will continue through until
  44.         'we reach the end of the picturebox. at that point, we will
  45.         'go back to our height loop. in other words, we are looping
  46.         'from left to right, two lines of pixels at a time, over and
  47.         'over again until we reach the extent of the picturebox's
  48.         'surface.
  49.             lngTop& = GetPixel(picSource.hDC, lngDoWidth&, lngDoHeight&)
  50.             'first we retreive the long color value of our pixel.
  51.             'i did try to use the point property of the picturebox,
  52.             'but it proved to be slower than the getpixel api.
  53.             lngBottom& = GetPixel(picSource.hDC, lngDoWidth&, lngDoHeight& + 1&)
  54.             'again we're getting the long color value of a pixel,
  55.             'except this time we're getting the pixel below the last.
  56.             'we do this because we are looping through two lines at
  57.             'a time (remember the step 2). we're going two lines at
  58.             'a time since to create a smooth ascii image, we must
  59.             'account for these two lines. you should be able to figure
  60.             'out why below.
  61.             If lngTop& = vbWhite And lngBottom& = vbWhite Then
  62.             'here we check to see if both pixels are white. if so,
  63.             'we know it is safe to use a space.
  64.               '  Text = ""
  65.                 strChar$ = " "
  66.             End If
  67.             If lngTop& <> vbWhite And lngBottom& <> vbWhite Then
  68.             'if both pixels are not white, we will fill our "space"
  69.             'with our ascii.
  70.                 strChar$ = ":"
  71.             End If
  72.             If lngTop& = vbWhite And lngBottom& <> vbWhite Then
  73.                 'if the top pixel is white, and the bottom is not,
  74.                 'then we will use a character which gives use the
  75.                 'appearance of a space on the top line and a fill
  76.                 'on the bottom line.
  77.                 strChar$ = ","
  78.             End If
  79.             If lngTop& <> vbWhite And lngBottom& = vbWhite Then
  80.                 'this is the opposite of the last if/then we just had.
  81.                 'here we are reacting to the top pixel not being white
  82.                 'and the bottom pixel being white.
  83.                 strChar$ = " "
  84.             End If
  85.             If lngTop& = -1 And lngBottom& = -1 Then
  86.                 'this is just here to account for an odd number of
  87.                 'pixels. if there is no pixel there, we get a -1 return
  88.                 'from getpixel. we use this since the return will not
  89.                 'be white and we don't want to end up with ascii characters
  90.                 'when they're not wanted.
  91.                 strChar$ = " "
  92.             End If
  93.             strLine$ = strLine$ & strChar$
  94.             'here we add our character to our current line.
  95.         Next
  96.         'in the following lines, if we have characters (not just a
  97.         'long line of spaces) we will trim the spaces off the right
  98.         'end of the string before adding them to our macro string.
  99.         If Trim(strLine$) <> ":" Then
  100.             strLine$ = RTrim(strLine$)
  101.         End If
  102.         If strMacro$ = ";" Then
  103.             strMacro$ = strLine$
  104.         Else
  105.             strMacro$ = strMacro$ & vbCrLf & strLine$
  106.         End If
  107.     Next
  108.     'the following code is not necessary, but i felt it was important
  109.     'to do since we would end up with an awful lot of spaces which
  110.     'were not needed. these two loops simply trim off the leading and
  111.     'trailing lines which are filled with spaces only.
  112.     blnFix = True
  113.     For lngFix& = 1 To LineCount(strMacro$)
  114.         strLine$ = LineFromString(strMacro$, lngFix&)
  115.         strTmp$ = Replace(strLine$, ";", ":")
  116.         strTmp$ = Replace(strTmp$, vbCrLf, ":")
  117.         If strTmp$ <> ";" Then
  118.             blnFix = False
  119.         End If
  120.         If blnFix = False Then
  121.             If strFinal$ = "" Then
  122.                 strFinal$ = strLine$
  123.             Else
  124.                 strFinal$ = strFinal$ & vbCrLf & strLine$
  125.             End If
  126.         End If
  127.     Next
  128.     blnFix = True
  129.     strMacro$ = " "
  130.     For lngFix& = LineCount(strFinal$) To 1 Step -1
  131.         strLine$ = LineFromString(strFinal$, lngFix&)
  132.         strTmp$ = Replace(strLine$, " ", " ")
  133.         strTmp$ = Replace(strTmp$, vbCrLf, " ")
  134.         If strTmp$ <> " " Then
  135.             blnFix = False
  136.         End If
  137.         If blnFix = False Then
  138.             If strMacro$ = " " Then
  139.                 strMacro$ = strLine$
  140.             Else
  141.                 strMacro$ = strLine$ & vbCrLf & strMacro$
  142.             End If
  143.         End If
  144.     Next
  145.     Convert$ = strMacro$
  146. End Function
  147.  
  148. 'the following functions should look familiar if you have dos32.bas.
  149. 'their purpose is to retreive the linecount from a string as well as
  150. 'extract a specific line from a string.
  151.  
  152. Public Function LineCount(strlngCount As String) As Long
  153.     Dim lngPos As Long, lngCount As Long
  154.     If Len(strlngCount$) < 1 Then
  155.         LineCount& = 0&
  156.         Exit Function
  157.     End If
  158.     lngPos& = InStr(strlngCount$, Chr(13))
  159.     If lngPos& <> 0& Then
  160.         LineCount& = 1
  161.         Do
  162.             lngPos& = InStr(lngPos + 1, strlngCount$, Chr(13))
  163.             If lngPos& <> 0& Then
  164.                 LineCount& = LineCount& + 1
  165.             End If
  166.         Loop Until lngPos& = 0&
  167.     End If
  168.     LineCount& = LineCount& + 1
  169. End Function
  170.  
  171. Public Function LineFromString(strSearch As String, lngLine As Long) As String
  172.     Dim strCurLine As String, lngCount As Long
  173.     Dim lngPos As Long, lngPosB As Long, lngDo As Long
  174.     lngCount& = LineCount(strSearch$)
  175.     If lngLine& > lngCount& Then
  176.         Exit Function
  177.     End If
  178.     If lngLine& = 1 And lngCount& = 1 Then
  179.         LineFromString$ = strSearch$
  180.         Exit Function
  181.     End If
  182.     If lngLine& = 1 Then
  183.         strCurLine$ = Left(strSearch$, InStr(strSearch$, Chr(13)) - 1)
  184.         strCurLine$ = Replace(strCurLine$, Chr(13), " ")
  185.         strCurLine$ = Replace(strCurLine$, Chr(10), " ")
  186.         LineFromString$ = strCurLine$
  187.         Exit Function
  188.     Else
  189.         lngPos& = InStr(strSearch$, Chr(13))
  190.         For lngDo& = 1 To lngLine& - 1
  191.             lngPosB& = lngPos&
  192.             lngPos& = InStr(lngPos& + 1, strSearch$, Chr(13))
  193.         Next lngDo
  194.         If lngPos = 0 Then
  195.             lngPos = Len(strSearch$)
  196.         End If
  197.         strCurLine$ = Mid(strSearch$, lngPosB&, lngPos& - lngPosB& + 1)
  198.         strCurLine$ = Replace(strCurLine$, Chr(13), " ")
  199.         strCurLine$ = Replace(strCurLine$, Chr(10), " ")
  200.         LineFromString$ = strCurLine$
  201.     End If
  202. End Function
  203.